home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_emacs.idb / usr / freeware / share / emacs / 19.34 / lisp / undigest.el.z / undigest.el
Encoding:
Text File  |  1998-10-28  |  6.0 KB  |  183 lines
  1. ;;; undigest.el --- digest-cracking support for the RMAIL mail reader
  2.  
  3. ;; Copyright (C) 1985, 1986, 1994, 1996 Free Software Foundation, Inc.
  4.  
  5. ;; Maintainer: FSF
  6. ;; Keywords: mail
  7.  
  8. ;; This file is part of GNU Emacs.
  9.  
  10. ;; GNU Emacs is free software; you can redistribute it and/or modify
  11. ;; it under the terms of the GNU General Public License as published by
  12. ;; the Free Software Foundation; either version 2, or (at your option)
  13. ;; any later version.
  14.  
  15. ;; GNU Emacs is distributed in the hope that it will be useful,
  16. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18. ;; GNU General Public License for more details.
  19.  
  20. ;; You should have received a copy of the GNU General Public License
  21. ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22. ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23. ;; Boston, MA 02111-1307, USA.
  24.  
  25. ;;; Commentary:
  26.  
  27. ;; See Internet RFC 934
  28.  
  29. ;;; Code:
  30.  
  31. (require 'rmail)
  32.  
  33. (defun undigestify-rmail-message ()
  34.   "Break up a digest message into its constituent messages.
  35. Leaves original message, deleted, before the undigestified messages."
  36.   (interactive)
  37.   (widen)
  38.   (let ((buffer-read-only nil)
  39.     (msg-string (buffer-substring (rmail-msgbeg rmail-current-message)
  40.                       (rmail-msgend rmail-current-message))))
  41.     (goto-char (rmail-msgend rmail-current-message))
  42.     (narrow-to-region (point) (point))
  43.     (insert msg-string)
  44.     (narrow-to-region (point-min) (1- (point-max))))
  45.   (let ((error t)
  46.     (buffer-read-only nil))
  47.     (unwind-protect
  48.     (progn
  49.       (save-restriction
  50.         (goto-char (point-min))
  51.         (delete-region (point-min)
  52.                (progn (search-forward "\n*** EOOH ***\n")
  53.                   (point)))
  54.         (insert "\^_\^L\n0, unseen,,\n*** EOOH ***\n")
  55.         (narrow-to-region (point)
  56.                   (point-max))
  57.         (let* ((fill-prefix "")
  58.            (case-fold-search t)
  59.            start
  60.            (digest-name
  61.             (mail-strip-quoted-names
  62.              (or (save-restriction
  63.                (search-forward "\n\n")
  64.                (setq start (point))
  65.                (narrow-to-region (point-min) (point))
  66.                (goto-char (point-max))
  67.                (or (mail-fetch-field "Reply-To")
  68.                    (mail-fetch-field "To")
  69.                    (mail-fetch-field "Apparently-To")
  70.                    (mail-fetch-field "From")))
  71.              (error "Message is not a digest--bad header")))))
  72.           (save-excursion
  73.         (goto-char (point-max))
  74.         (skip-chars-backward " \t\n")
  75.         (let (found)
  76.           ;; compensate for broken un*x digestifiers.  Sigh Sigh.
  77.           (while (and (> (point) start) (not found))
  78.             (forward-line -1)
  79.             (if (looking-at (concat "End of.*Digest.*\n"
  80.                         (regexp-quote "*********") "*"
  81.                         "\\(\n------*\\)*"))
  82.             (setq found t)))
  83.           (if (not found)
  84.               (error "Message is not a digest--no end line"))))
  85.           (re-search-forward (concat "^" (make-string 55 ?-) "-*\n*"))
  86.           (replace-match "\^_\^L\n0, unseen,,\n*** EOOH ***\n")
  87.           (save-restriction
  88.         (narrow-to-region (point)
  89.                   (progn (search-forward "\n\n")
  90.                      (point)))
  91.         (if (mail-fetch-field "To") nil
  92.           (goto-char (point-min))
  93.           (insert "To: " digest-name "\n")))
  94.           (while (re-search-forward
  95.               (concat "\n\n" (make-string 27 ?-) "-*\n*")
  96.               nil t)
  97.         (replace-match "\n\n\^_\^L\n0, unseen,,\n*** EOOH ***\n")
  98.         (save-restriction
  99.           (if (looking-at "End ")
  100.               (insert "To: " digest-name "\n\n")
  101.             (narrow-to-region (point)
  102.                       (progn (search-forward "\n\n"
  103.                                  nil 'move)
  104.                          (point))))
  105.           (if (mail-fetch-field "To")
  106.               nil
  107.             (goto-char (point-min))
  108.             (insert "To: " digest-name "\n")))
  109.         ;; Digestifiers may insert `- ' on lines that start with `-'.
  110.         ;; Undo that.
  111.         (save-excursion
  112.           (goto-char (point-min))
  113.           (if (re-search-forward
  114.                "\n\n----------------------------*\n*"
  115.                nil t)
  116.               (let ((end (point-marker)))
  117.             (goto-char (point-min))
  118.             (while (re-search-forward "^- " end t)
  119.               (delete-char -2)))))
  120.         )))
  121.       (setq error nil)
  122.       (message "Message successfully undigestified")
  123.       (let ((n rmail-current-message))
  124.         (rmail-forget-messages)
  125.         (rmail-show-message n)
  126.         (rmail-delete-forward)
  127.         (if (rmail-summary-exists)
  128.         (rmail-select-summary
  129.          (rmail-update-summary)))))
  130.       (cond (error
  131.          (narrow-to-region (point-min) (1+ (point-max)))
  132.          (delete-region (point-min) (point-max))
  133.          (rmail-show-message rmail-current-message))))))
  134.  
  135. (defun unforward-rmail-message ()
  136.   "Extract a forwarded message from the containing message.
  137. This puts the forwarded message into a separate rmail message
  138. following the containing message."
  139.   (interactive)
  140.   ;; Don't use save-excursion because we don't want to restore point
  141.   ;; in the case where we do not switch buffers.
  142.   (let ((obuf (current-buffer)))
  143.     (unwind-protect
  144.     (progn
  145.       ;; If we are in a summary buffer, switch to the Rmail buffer.
  146.       (if (local-variable-p 'rmail-buffer)
  147.           (set-buffer rmail-buffer))
  148.       (narrow-to-region (rmail-msgbeg rmail-current-message)
  149.                 (rmail-msgend rmail-current-message))
  150.       (goto-char (point-min))
  151.       (let (beg end (buffer-read-only nil) msg-string who-forwarded-it)
  152.         (setq who-forwarded-it (mail-fetch-field "From"))
  153.         (if (re-search-forward "^----" nil t)
  154.         nil
  155.           (error "No forwarded message"))
  156.         (forward-line 1)
  157.         (setq beg (point))
  158.         (if (re-search-forward "^----" nil t)
  159.         (setq end (match-beginning 0))
  160.           (error "No terminator for forwarded message"))
  161.         (widen)
  162.         (setq msg-string (buffer-substring beg end))
  163.         (goto-char (rmail-msgend rmail-current-message))
  164.         (narrow-to-region (point) (point))
  165.         (insert "\^_\^L\n0, unseen,,\n*** EOOH ***\n")
  166.         (narrow-to-region (point) (point))
  167.         (insert "Forwarded-by: " who-forwarded-it "\n")
  168.         (insert msg-string)
  169.         (goto-char (point-min))
  170.         (while (not (eobp))
  171.           (if (looking-at "- ")
  172.           (delete-region (point) (+ 2 (point))))
  173.           (forward-line 1))
  174.         (let ((n rmail-current-message))
  175.           (rmail-forget-messages)
  176.           (rmail-show-message n)
  177.           (if (rmail-summary-exists)
  178.           (rmail-select-summary
  179.            (rmail-update-summary))))))
  180.       (set-buffer obuf))))
  181.  
  182. ;;; undigest.el ends here
  183.